home *** CD-ROM | disk | FTP | other *** search
/ Disc to the Future 2 / Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin / MAC / MPW_TOOL / TOOLS / TOOLS_WI / ICON_8 / ICONX_FO / OMISC.C < prev    next >
Text File  |  1990-03-02  |  7KB  |  304 lines
  1. /*
  2.  * File: omisc.c
  3.  *  Contents: refresh, size, tabmat, toby
  4.  */
  5.  
  6. #include "::h:config.h"
  7. #include "::h:rt.h"
  8. #include "rproto.h"
  9.  
  10. #ifdef PreProcess
  11. /* include(../M4/ops.m4) /* */
  12. /* */
  13. #endif                    /* PreProcess */
  14.  
  15. /*
  16.  * ^x - return an entry block for co-expression x from the refresh block.
  17.  */
  18.  
  19. OpDcl(refresh,1,"^")
  20.    {
  21.  
  22. #ifdef Coexpr
  23.    register struct b_coexpr *sblkp;
  24.    register struct b_refresh *rblkp;
  25.    register dptr dp, dsp;
  26.    register word *newsp;
  27.    int na, nl, i;
  28.  
  29.    /*
  30.     * Be sure a co-expression is being refreshed.
  31.     */
  32.    if (Qual(Arg1) || Arg1.dword != D_Coexpr) 
  33.       RunErr(118, &Arg1);
  34.  
  35.    /*
  36.     * Get a new co-expression stack and initialize.
  37.     */
  38.    if ((sblkp = alccoexp()) == NULL) 
  39.       RunErr(0, NULL);
  40.    sblkp->freshblk = BlkLoc(Arg1)->coexpr.freshblk;
  41.    if (ChkNull(sblkp->freshblk))    /* &main cannot be refreshed */
  42.       RunErr(215, &Arg1);
  43.  
  44.    /*
  45.     * The interpreter stack starts at word after co-expression stack block.
  46.     *  C stack starts at end of stack region on machines with down-growing C
  47.     *  stacks and somewhere in the middle of the region.
  48.     *
  49.     * The C stack is aligned on a doubleword boundary.    For upgrowing
  50.     *  stacks, the C stack starts in the middle of the stack portion
  51.     *  of the static block.  For downgrowing stacks, the C stack starts
  52.     *  at the last word of the static block.
  53.     */
  54.    newsp = (word *)((word)(char *)sblkp + sizeof(struct b_coexpr));
  55.  
  56. #ifdef UpStack
  57.    sblkp->cstate[0] =
  58.       ((word)((word)(char *)sblkp + (stksize - sizeof(*sblkp))/2)
  59.        &~(WordSize*StackAlign-1));
  60. #else                    /* UpStack */
  61.    sblkp->cstate[0] =
  62.     ((word)((word)(char *)sblkp + stksize - WordSize)&~(WordSize*StackAlign-1));
  63. #endif                    /* UpStack */
  64.  
  65.    sblkp->es_argp = (dptr)newsp;
  66.  
  67.    /*
  68.     * Get pointer to refresh block and get number of arguments and locals.
  69.     */
  70.  
  71.    rblkp = (struct b_refresh *)BlkLoc(sblkp->freshblk);
  72.    na = (rblkp->pfmkr).pf_nargs + 1;
  73.    nl = (int)rblkp->numlocals;
  74.  
  75.    /*
  76.     * Copy arguments onto new stack.
  77.     */
  78.    dp = &rblkp->elems[0];
  79.    dsp = (dptr)newsp;
  80.    for (i = 1; i <= na; i++)
  81.       *dsp++ = *dp++;
  82.  
  83.    /*
  84.     * Copy procedure frame to new stack and point dsp to word after frame.
  85.     */
  86.    *((struct pf_marker *)dsp) = rblkp->pfmkr;
  87.    sblkp->es_pfp = (struct pf_marker *)dsp;
  88. /*   dsp = (dptr)((word *)dsp + Vwsizeof(*pfp)); */
  89.    dsp = (dptr)((word)dsp + sizeof(word) * Vwsizeof(*pfp));
  90.    sblkp->es_ipc.opnd = rblkp->ep;
  91.    sblkp->es_gfp = 0;
  92.    sblkp->es_efp = 0;
  93.    sblkp->tvalloc = NULL;
  94.    sblkp->es_ilevel = 0;
  95.  
  96.    /*
  97.     * Copy locals to new stack and refresh block.
  98.     */
  99.    for (i = 1; i <= nl; i++)
  100.       *dsp++ = *dp++;
  101.  
  102.    /*
  103.     * Push two null descriptors on the stack.
  104.     */
  105.    *dsp++ = nulldesc;
  106.    *dsp++ = nulldesc;
  107.  
  108.    sblkp->es_sp = (word *)dsp - 1;
  109.  
  110.    /*
  111.     * Return the new co-expression.
  112.     */
  113.    Arg0.dword = D_Coexpr;
  114.    BlkLoc(Arg0) = (union block *) sblkp;
  115.    Return;
  116.  
  117. #else                    /* Coexpr */
  118.    RunErr(-401, NULL);
  119. #endif                    /* Coexpr */
  120.  
  121.    }
  122.  
  123. /*
  124.  * *x - return size of string or object x.
  125.  */
  126.  
  127. OpDcl(size,1,"*")
  128.    {
  129.    char sbuf[MaxCvtLen];
  130.    word i;
  131.    int j;
  132.    union block *bp;
  133.  
  134.    if (Qual(Arg1)) {
  135.       /*
  136.        * If Arg1 is a string, return the length of the string.
  137.        */
  138.       i = StrLen(Arg1);
  139.       }
  140.  
  141.    else {
  142.       /*
  143.        * Arg1 is not a string.  For most types, the size is in the size
  144.        *  field of the block.
  145.        *  structure.
  146.        */
  147.       switch (Type(Arg1)) {
  148.          case T_List:
  149.             i = BlkLoc(Arg1)->list.size;
  150.             break;
  151.  
  152.          case T_Table:
  153.             i = BlkLoc(Arg1)->table.size;
  154.             break;
  155.  
  156.          case T_Set:
  157.             i = BlkLoc(Arg1)->set.size;
  158.             break;
  159.  
  160.          case T_Cset: {
  161.         register unsigned int w;
  162.  
  163.             i = BlkLoc(Arg1)->cset.size;
  164.             if (i >= 0)
  165.                break;
  166.             bp = (union block *)BlkLoc(Arg1);
  167.             i = 0;
  168.             for (j = 0; j < CsetSize; j++)
  169.            for (w=bp->cset.bits[j]; w; w >>= 1)
  170.           if (w & 01)
  171.              i++;
  172.             bp->cset.size = i;
  173.             break;
  174.         }
  175.  
  176.          case T_Record:
  177.             i = BlkLoc(Arg1)->record.recdesc->proc.nfields;
  178.             break;
  179.  
  180.          case T_Coexpr:
  181.  
  182.             i = BlkLoc(Arg1)->coexpr.size;
  183.             break;
  184.  
  185.          default:
  186.             /*
  187.              * Try to convert it to a string.
  188.              */
  189.             if (cvstr(&Arg1, sbuf) == CvtFail) 
  190.                RunErr(112, &Arg1);    /* no notion of size */
  191.             i = StrLen(Arg1);
  192.          }
  193.       }
  194.    MakeInt(i, &Arg0);
  195.    Return;
  196.    }
  197.  
  198. /*
  199.  * =x - tab(match(x)).  Reverses effects if resumed.
  200.  */
  201.  
  202. OpDcl(tabmat,1,"=")
  203.    {
  204.    register word l;
  205.    register char *s1, *s2;
  206.    word i, j;
  207.    char sbuf[MaxCvtLen];
  208.    int type;
  209.  
  210.    /*
  211.     * Arg1 must be a string.
  212.     */
  213.    if ((type = cvstr(&Arg1,sbuf)) == CvtFail) 
  214.       RunErr(103, &Arg1);
  215.  
  216.    /*
  217.     * Make a copy of &pos.
  218.     */
  219.    i = k_pos;
  220.  
  221.    /*
  222.     * Fail if &subject[&pos:0] is not of sufficient length to contain Arg1.
  223.     */
  224.    j = StrLen(k_subject) - i + 1;
  225.    if (j < StrLen(Arg1))
  226.       Fail;
  227.  
  228.    /*
  229.     * Get pointers to Arg1 (s1) and &subject (s2).  Compare them on a bytewise
  230.     *  basis and fail if s1 doesn't match s2 for *s1 characters.
  231.     */
  232.    s1 = StrLoc(Arg1);
  233.    s2 = StrLoc(k_subject) + i - 1;
  234.    l = StrLen(Arg1);
  235.    while (l-- > 0) {
  236.       if (*s1++ != *s2++)
  237.          Fail;
  238.       }
  239.  
  240.    /*
  241.     * Increment &pos to tab over the matched string and suspend the
  242.     *  matched string.
  243.     */
  244.    l = StrLen(Arg1);
  245.    k_pos += l;
  246.    Arg0 = Arg1;
  247.    if (type == Cvt) {        /* string is in buffer, copy */
  248.       if (strreq(StrLen(Arg0)) == Error) 
  249.          RunErr(0, NULL);
  250.       StrLoc(Arg0) = alcstr(StrLoc(Arg0), StrLen(Arg0));
  251.       }
  252.    Suspend;
  253.  
  254.    /*
  255.     * tabmat has been resumed, restore &pos and fail.
  256.     */
  257.    if (i > StrLen(k_subject) + 1) {
  258.       RunErr(205, &tvky_pos.kyval);
  259.       }
  260.    else
  261.       k_pos = i;
  262.    Fail;
  263.    }
  264.  
  265. /*
  266.  * i to j by k - generate successive values.
  267.  */
  268.  
  269. OpDcl(toby,3,"...")
  270.    {
  271.    long from;
  272.  
  273.    /*
  274.     * Arg1 (from), Arg2 (to), and Arg3 (by) must be integers.
  275.     *  Also, Arg3 must not be zero.
  276.     */
  277.    if (cvint(&Arg1) == CvtFail) 
  278.       RunErr(101, &Arg1);
  279.    if (cvint(&Arg2) == CvtFail) 
  280.       RunErr(101, &Arg2);
  281.    if (cvint(&Arg3) == CvtFail) 
  282.       RunErr(101, &Arg3);
  283.    if (IntVal(Arg3) == 0) 
  284.       RunErr(211, &Arg3);
  285.  
  286.    /*
  287.     * Count up or down (depending on relationship of from and to) and
  288.     *  suspend each value in sequence, failing when the limit has been
  289.     *  exceeded.
  290.     */
  291.    from = IntVal(Arg1);
  292.    if (IntVal(Arg3) > 0)
  293.       for ( ; from <= IntVal(Arg2); from += IntVal(Arg3)) {
  294.      MakeInt(from, &Arg0);
  295.          Suspend;
  296.          }
  297.    else
  298.       for ( ; from >= IntVal(Arg2); from += IntVal(Arg3)) {
  299.      MakeInt(from, &Arg0);
  300.          Suspend;
  301.          }
  302.    Fail;
  303.    }
  304.